home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / front_end / spfix.t < prev    next >
Encoding:
Text File  |  1990-04-12  |  3.5 KB  |  100 lines
  1. (herald spfix)
  2.  
  3. (define (orbit-sparc-setup directory)
  4.   (set *object-file-extension* 'so)
  5.   (set *information-file-extension* 'si)
  6.   (set *noise-file-extension* 'sn)
  7.   (set *debug-file-extension* 'sd)
  8.   (orbit-setup directory)
  9.   (set (table-entry *modules* 'constants) `(,directory spconstants))
  10.   (set (table-entry *modules* 'primops)   `(,directory spprimops))
  11.   (set (table-entry *modules* 'arith)     `(,directory sparith))
  12.   (set (table-entry *modules* 'low)       `(,directory splow))
  13.   (set (table-entry *modules* 'genarith)     `(,directory spgenarith))
  14.   nil)
  15.  
  16. (define (orbit-sparc-init . directory)
  17.   (orbit-sparc-setup (if directory (car directory) '#f))
  18.   (orbit-init 'base
  19.               'constants
  20.               'primops
  21.           'arith
  22.               'locations
  23.               'low
  24.           'predicates
  25.               'open
  26.               'aliases
  27.               'carcdr
  28.               'genarith))
  29.  
  30. (define (add-label-assigner var thunk parent)
  31.   (cond ((thunk-value thunk)
  32.          => (lambda (value)
  33.               (add-simple-label-assigner var (detach value) parent)
  34.               (splice-thunk thunk parent)))
  35.         (else
  36.          (let* ((c-var (create-variable 'k))
  37.                 (value (create-reference-node c-var)))
  38.            (add-simple-label-assigner var value parent)
  39.            (var-gets-thunk-value c-var thunk parent)
  40.        (let ((node (node-parent thunk)))
  41.          (walk (lambda (var val)
  42.              (if (lambda-node? val)
  43.              (check-continuation-var var val)))
  44.            (lambda-variables (call-proc node))
  45.            (call-args node)))))))
  46.  
  47. (define (check-continuation-var var val)
  48.   (walk-refs-safely (lambda (ref)
  49.               (if (call-exit? ref)
  50.               (fix-exit-reference var ref val)))
  51.             var))
  52.  
  53. (define (introduce-exit-lambda var node value args?)
  54.   (let* ((new-vars (free-map (lambda (var)
  55.                                (if var
  56.                                    (create-variable (variable-name var))
  57.                                    nil))
  58.                              (lambda-rest+variables value)))
  59.          (cont (create-lambda-node 'c new-vars))
  60.          (args (if (not args?)
  61.                    '()
  62.                    (map (lambda (v) (if v
  63.                                         (create-reference-node v)
  64.                                         (create-literal-node '#f)))
  65.                         (cdr new-vars))))
  66.          (call (create-call-node (fx+ '1 (length args)) '0)))
  67.     (relate call-proc call (create-reference-node var))
  68.     (relate-call-args call args)
  69.     (relate lambda-body cont call)
  70.     (replace node cont)))
  71.  
  72. (define (complexity-analyze node)
  73.   (cond ((empty? node)
  74.          '0)
  75.         ((reference-node? node)
  76.          (cond ((get-variable-definition (reference-variable node)) 0)
  77.                ((call-arg-mismatches? node) 1)
  78.                (else 2)))
  79.         ((leaf-node? node) '0)
  80.         ((lambda-node? node)
  81.          (complexity-analyze (lambda-body node)))
  82.         ((call-node? node)
  83.          (let ((q (complexity-analyze-list (call-proc+args node))))
  84.            (set (call-complexity node) q)
  85.            q))
  86.         ((object-node? node)
  87.          (let ((q1 (complexity-analyze (object-proc node)))
  88.                (q2 (complexity-analyze-list (object-operations node)))
  89.                (q3 (complexity-analyze-list (object-methods node))))
  90.            (fx+ q1 (fx+ q2 q3))))
  91.         (else
  92.          (bug '"funny node ~S" node))))
  93.                     
  94. (define (call-arg-mismatches? node)
  95.   (let ((var (reference-variable node)))
  96.     (and (variable-binder var)
  97.          (fxn= (call-arg-number (node-role node))
  98.                (fx- (variable-number var) 1)))))
  99.  
  100.